home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / rbbs_pc / 173amrg.zip / RSB1173A.MRG < prev    next >
Text File  |  1990-08-26  |  11KB  |  306 lines
  1. * ------------[ BLED merge (c) Ken Goosens ]-------------
  2. * Merge this against D:\172B\RBBSSUB1.BAS to produce RBBSSUB1.BAS
  3. * D:\172B\RBBSSUB1.BAS:  Date 2-10-1990  Size 53454 bytes
  4. * ------------[ Created 08-26-1990 11:28:06 ]------------
  5. * REPLACING old line(s) by new
  6. ' $linesize:132
  7. * ------[ first line different ]------
  8. ' $title: 'RBBS-SUB1.BAS 17.3A, Copyright 1986-90 by D. Thomas Mack' ' DA081003
  9. '  Copyright 1990 by D. Thomas Mack, all rights reserved.
  10. '  Name ...............: RBBSSUB1.BAS
  11. '  First Released .....: February 11, 1990
  12. '  Subsequent Releases.: August 26, 1990
  13. '  Copyright ..........: 1986-1990
  14. '  Purpose.............:
  15. '     Subprorams that require error trapping are incorporated
  16. '     within RBBSSUB1.BAS as separately callable subroutines
  17. '     in order to free up as much code as possible within
  18. '     the 64WasK code segment used by RBBS-PC.BAS.
  19. '  Parameters..........: Most parameters are passed via a COMMON statement.
  20. '
  21. ' Subroutine  Line               Function of Subroutine
  22. '   Name     Number
  23. '  ChangeDir   20101   Change subdirectory
  24. '  CheckInt    58360   Check input is valid integer
  25. '  CommPut     59275   Write string to communications port
  26. '  FindFile    59790   Determine whether a file exists without opening it
  27. '  FindFree    51098   Find amount of space on the upload disk drive
  28. '  FindItX     20219   Find if a file exists on a device
  29. '  FindUser    12598   Find a user in the USERS file
  30. '  FlushCom    20308   Read all characters in the communications port
  31. '  GetCom       1418   Read a character from the communications port
  32. '  GetPassword 58280   Read RBBS-PC's "PASSWORD" file
  33. '  GETWRK      58330   Read record from file number 2
  34. '  KillWork    58258   Delete a RBBS-PC "WORK" file
  35. '  NetBIOS     20898   Lock/Unlock NetBIOS semaphore files
  36. '  OpenCom       200   Open communications port (number 3)
  37. '  OpenFMS     58188   Open the upload management system directory
  38. '  OpenOutW    28218   Open RBBS-PC's "WORK" file (number 2) for output
  39. '  OpenRSeq     1479   Open a sequential file (number 2) for random I/O
  40. '  OpenUser     9398   Open the USER file (number 5)
  41. '  OpenWork    57978   Open RBBS-PC's work file (number 2)
  42. '  OpenWorkA   58340   Open RBBS-PC's "WORK" file (number 2) for append
  43. '  Printit     13673   Print line on the local PC printer
  44. '  PrintWork   58320   Print string to file #2 w/o CR/LF
  45. '  PrintWorkA  58350   Print string to file #2 with CR/LF
  46. '  PutCom      59650   Write to the communications port
  47. '  PutWork     59660   Write to work file randomly
  48. '  RBBSPlay    59680   Plays a musical string
  49. '  ReadAny     58310   Read file number 2 into ZOutTxt$
  50. '  ReadDef       112   Read configuration file
  51. '  ReadDir     58290   Read entire lines
  52. '  ReadParms   58300   Read certain number of parameters from file 2
  53. '  Talk        59700   RBBS-PC Voice synthesizer support for sight impaired
  54. '  SetCall       108   Find where next callers record is
  55. '  UpdateC     43048   Update the caller's file with elasped session time
  56. '  UpdtCalr    13661   Update to the caller's file
  57. '
  58. '  $INCLUDE: 'RBBS-VAR.BAS'
  59. '
  60. * REPLACING old line(s) by new
  61. 108 ' $SUBTITLE: 'SetCall - subroutine to find last callers rec'
  62. ' $PAGE
  63. '
  64. '  NAME    -- SetCall
  65. '
  66. '  INPUTS  --     PARAMETER                    MEANING
  67. '
  68. '  OUTPUTS --  ZCallersFileIndex!
  69. '
  70. '  PURPOSE --  To find where to leave off on callers file
  71. '
  72.     SUB SetCall STATIC
  73.     ON ERROR GOTO 65000
  74. * ------[ first line different ]------
  75.     IF ZPrevCaller$ = ZCallersFile$ OR ZCallersFilePrefix$ = "" THEN _ ' KG052401
  76.        EXIT SUB
  77.     ZPrevCaller$ = ZCallersFile$                                     ' KG052401
  78.     ZCallersFileIndex! = 1
  79.     CLOSE 2
  80.     CLOSE 4
  81.     IF ZShareIt THEN _
  82.        OPEN ZCallersFile$ FOR RANDOM SHARED AS #4 LEN=64 _
  83.     ELSE OPEN "R",4,ZCallersFile$,64
  84.     FIELD 4,64 AS ZCallersRecord$
  85.     IF LOF(4) > 0 THEN _
  86.        ZCallersFileIndex! = LOF(4) / 64
  87.     IF ZCallersFileIndex! < 1 THEN _
  88.        ZCallersFileIndex! = 0
  89.     ZUserIn$ = STRING$(13,0)
  90. * REPLACING old line(s) by new
  91. 110 GET 4,ZCallersFileIndex!
  92.     IF ZErrCode > 0 THEN _
  93.        ZErrCode = 0 : _
  94.        ZCallersFileIndex! = 0 : _
  95.        EXIT SUB
  96.     IF LEFT$(ZCallersRecord$,13) = ZUserIn$ THEN _
  97.        ZCallersFileIndex! = ZCallersFileIndex! - 1 : _
  98.        GOTO 110
  99.     END SUB
  100. * ------[ first line different ]------
  101. * REPLACING old line(s) by new
  102. 12600 ZWasY$ = IndivToLookFor$ + SPACE$(LenIndivField - LEN(IndivToLookFor$))
  103.       PosToReclaim = 0
  104. * ------[ first line different ]------
  105.       ZErrCode = 0                                                   ' KG061001
  106. * REPLACING old line(s) by new
  107. 12610 GET 5,PosToUse
  108.       IF ZErrCode > 0 THEN _
  109.          IF ZErrCode = 63 THEN _
  110.             ZErrCode = 0 : _
  111.             GOTO 12621 _
  112.          ELSE ZErrCode = 0 : _
  113. * ------[ first line different ]------
  114.               GOTO 12620                                             ' KG061001
  115.       HashValue$ = MID$(Filler$,StartHashPos,LenHashField)
  116.       IF WasX$ = HashValue$ THEN _
  117.          IF StartIndivPos < 1 THEN _
  118.             WhetherFound = ZTrue : _                                 ' KG061001
  119.             GOTO 12622 _                                             ' KG061001
  120.          ELSE IndivValue$ = MID$(Filler$,StartIndivPos,LenIndivField) : _
  121.               IF ZWasY$ = IndivValue$ OR IndivValue$ = EmptyIndiv$ THEN _
  122.                  WhetherFound = ZTrue : _
  123.                  GOTO 12622
  124.       IF HashValue$ = EmptyRec$ THEN _
  125.          PosToUse = PosToReclaim - (PosToReclaim = 0) * PosToUse : _
  126.          WhetherFound = ZFalse : _
  127.          GOTO 12622
  128.       IF ASC(HashValue$) = 0 OR INSTR(HashValue$,NewUser$) = 1 THEN _
  129.          IF PosToReclaim = 0 THEN _
  130.             PosToReclaim = PosToUse
  131. * REPLACING old line(s) by new
  132. 13670 LSET ZCallersRecord$ = WasX$
  133. * ------[ first line different ]------
  134.       CALL Printit (ZCallersRecord$)                                 ' KG052702
  135.       ZCallersFileIndex! = ZCallersFileIndex! + 1
  136. * REPLACING old line(s) by new
  137. 29920 ZErrCode = 0
  138.       IF IBMFileLock = 6 AND IBMRecLock = 3 THEN _
  139.          IBMCount = IBMCount - 1 : _
  140.          IF IBMCount > 0 THEN _
  141.             EXIT SUB _
  142.          ELSE IBMCount = 0
  143.       UNLOCK IBMFileLock, IBMRecLock TO IBMRecLock
  144. * ------[ first line different ]------
  145.       IF ZErrCode = 70 THEN _                                        ' ML041401
  146.          EXIT SUB                                                    ' ML041401
  147.       IF ZErrCode <> 0 THEN _
  148.          GOTO 29920
  149.       END SUB
  150. * REPLACING old line(s) by new
  151. 65000 IF ZDebug THEN _
  152.          ZOutTxt$ = "RBBSSUB1 DEBUG Error Trap Entry ERL=" + _
  153.               STR$(ERL) + _
  154.               " ERR=" + _
  155.               STR$(ERR) : _
  156.          IF ZPrinter THEN _
  157.             CALL Printit(ZOutTxt$) _
  158.          ELSE CALL LPrnt(ZOutTxt$,1)
  159.       ZErrCode = ERR
  160. '
  161. '     SetCall
  162. '
  163. * ------[ first line different ]------
  164.       IF ERL = 108 THEN _
  165.          CALL PScrn ("Unable to create callers log " + ZCallersFile$) : _ ' KG081602
  166.          SYSTEM                                                      ' KG081602
  167.       IF ERL = 110 THEN _
  168.           RESUME NEXT
  169. '
  170. '     OPEN CONFIG FILE
  171. '
  172.        IF ERL => 117 AND ERL <= 119 THEN _
  173.           RESUME NEXT
  174. '
  175. '     OPEN COM PORT ERROR HANDLING
  176. '
  177.       IF ERL = 200 THEN _
  178.          CLS : _
  179.          CALL PScrn (ZComPort$ + " does not exist/not responding- Error" + STR$(ERR)) : _
  180.          STOP
  181. '
  182. '     GetCom ERROR HANDLING
  183. '
  184.        IF ERL = 1420 AND ERR = 57 THEN _
  185.           RESUME NEXT
  186.        IF ERL = 1420 AND ERR = 69 THEN _
  187.           ZSubParm = -1 :_
  188.           RESUME NEXT
  189. '
  190. '      OPENRESEQ ERROR HANDLING
  191. '
  192.        IF ERL = 1481 THEN _
  193.            ZErrCode = ERR : _
  194.            RESUME NEXT
  195. '
  196. '      OpenUser ERROR HANDLING
  197. '
  198.        IF ERL = 9400 AND ERR = 75 AND ZShareIt THEN _
  199.           CALL DelayTime (30) : _
  200.           RESUME
  201. '
  202. '      FindUser ERROR HANDLING
  203. '
  204.        IF ERL = 12610 OR ERL = 12600 THEN _                          ' KG061001
  205.           RESUME NEXT
  206. '
  207. '     UpdtCalr ERROR HANDLING
  208. '
  209.        IF ERL = 13663 THEN _
  210.           RESUME NEXT
  211.        IF ERL = 13672 AND ERR = 61 THEN _
  212.           CALL QuickTPut1 ("Disk Full") : _
  213.           IF ZDiskFullGoOffline THEN _
  214.              GOTO 65010 _
  215.           ELSE RESUME NEXT
  216.        IF ERL = 13672 THEN _
  217.           ZCallersFileIndex! = ZCallersFileIndex! - 1 : _
  218.           RESUME NEXT
  219. '
  220. '     ZPrinter ERROR HANDLING
  221. '
  222.        IF ERL = 13674 THEN _
  223.           ZPrinter = ZFalse : _
  224.           RESUME
  225. '
  226. '      ChangeDir ERROR HANDLING
  227. '
  228.        IF ERL = 20103 THEN _
  229.           ZOK = ZFalse : _
  230.           RESUME NEXT
  231. '
  232. '     FindIt ERROR HANDLING
  233. '
  234.        IF ERL = 20221 THEN _
  235.           RESUME NEXT
  236.        IF ERL = 20223 AND ZErrCode = 58 THEN _
  237.           ZErrCode = 64 : _
  238.           ZOK = ZFalse : _
  239.           RESUME NEXT
  240.        IF ERL = 20223 AND ZErrCode = 76 THEN _
  241.           CALL LPrnt("Bad path.  File name is " + FilName$,1) : _
  242.           ZErrCode = 76 : _
  243.           ZOK = ZFalse : _
  244.           RESUME NEXT
  245.        IF ERL => 20221 AND ERL <= 20223 AND ZErrCode = 70 _
  246.           AND ZNetworkType = 6 THEN _
  247.              ZErrCode = 0 : _
  248.              RESUME NEXT
  249.        IF ERL => 20221 AND ERL <= 20223 THEN _
  250.           RESUME
  251. '
  252. '     FlushCom ERROR HANDLING
  253. '
  254.        IF ERL = 20311 AND ERR = 57 THEN _
  255.           RESUME NEXT
  256.        IF ERL = 20311 AND ERR = 69 THEN _
  257.           ZAbort = ZTrue : _
  258.           ZSubParm = -1 : _
  259.           RESUME NEXT
  260. '
  261. '     NetBIOS ERROR HANDLING
  262. '
  263.        IF ERL => 29900 AND ERL <= 29920 THEN _
  264.           RESUME NEXT
  265. '
  266. '     UpdateC ERROR HANDLING
  267. '
  268.       IF ERL => 43050 AND ERL <= 43060 AND ERR = 61 THEN _
  269.          ZOutTxt$ = "* Disk full - terminating *" : _
  270.          ZSubParm =2 : _
  271.          CALL TPut : _
  272.          IF ZDiskFullGoOffline THEN _
  273.            GOTO 65010 _
  274.          ELSE SYSTEM
  275. '
  276. '     CheckInt ERROR HANDLING
  277. '
  278.        IF (ERL = 59652 OR ERL = 59727) AND ERR = 24 THEN _
  279.           ZNotCTS = ZTrue : _
  280.           CALL Line25 : _
  281.           ZErrCode = 0 : _
  282.           RESUME
  283.        IF ERL => 52000 AND ERL <= 59725 THEN _
  284.           RESUME NEXT
  285. '
  286. '     FindFile ERROR HANDLING
  287. '
  288.        IF ERL = 59791 THEN _
  289.           IF ERR = 57 THEN _
  290.              CALL DelayTime (1) : _
  291.              CALL UpdtCalr ("SLOW I/O ERROR",1) : _
  292.              IOErrorCount = IOErrorCount + 1 : _
  293.              IF IOErrorCount < 11 THEN _
  294.                 RESUME
  295. '
  296. '     CATCH ALL OTHER ERRORS
  297. '
  298.        ZOutTxt$ = "RBBS-SUB1 Untrapped Error" + _
  299.             STR$(ERR) + _
  300.             " in line" + _
  301.             STR$(ERL)
  302.        CALL QuickTPut1 (ZOutTxt$)
  303.        CALL UpdtCalr (ZOutTxt$,2)
  304.        RESUME NEXT
  305. '     SHARED ROUTINE FOR GOING OFF LINE WHEN DISK FULL
  306.